Dla zapewnienia powtarzalności wyników przy każdym uruchomieniu raportu dla tych samych danych, ustawiono ziarno dla generatora liczb pseudolosowych.
set.seed(23)
Raport został stworzony przy wykorzystaniu następujących bibliotek.
library(dplyr)
library(ggplot2)
library(tidyr)
library(tibble)
library(plotly)
library(gganimate)
library(caret)
library(randomForest)
colors <- read.csv("dataset/colors.csv")
parts_cat <- read.csv("dataset/part_categories.csv")
elements <- read.csv("dataset/elements.csv")
parts <- read.csv("dataset/parts.csv")
inv_parts <- read.csv("dataset/inventory_parts.csv")
figs <- read.csv("dataset/minifigs.csv")
inv_figs <- read.csv("dataset/inventory_minifigs.csv")
themes <- read.csv("dataset/themes.csv")
sets <- read.csv("dataset/sets.csv")
inv_sets <- read.csv("dataset/inventory_sets.csv")
inventories <- read.csv("dataset/inventories.csv")
Ta sekcja poświęcona jest przetworzeniu brakujących wartości oraz transformacji wykorzystanych zbiorów danych.
Pierwsza i bardzo ważna część badanego zbioru danych. Zawierają się tutaj informacje o zestawach Lego, takie jak rok wydania oraz ilość części w zestawie, ale też lata w jakich dany zestaw zadebiutował na rynku.
themes <- setNames(themes, c("theme_id", "theme_name", "parent_id"))
colnames(sets)[colnames(sets) == "name"] <- "set_name"
colnames(sets)[colnames(sets) == "num_parts"] <- "set_num_parts"
colnames(inv_sets)[colnames(inv_sets) == "quantity"] <- "set_qty"
sets_with_themes <- themes %>%
merge(sets, by = "theme_id") %>%
select(-c("theme_id","img_url","parent_id"))
Na wykresach można zaobserwować pewien trend. Wskazuje on na to, że wraz z upływem czasu powstaje coraz więcej zestawów Lego. Dodatkowo są one coraz większe i bardziej rozbudowane, na co wskazuje rosnąca liczba części.
unique_theme_data <- sets_with_themes %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(unique_theme = n_distinct(theme_name, na.rm = TRUE))
ggplot(unique_theme_data , aes(x = year, y = unique_theme)) +
geom_line(aes(y = unique_theme, color = "Unikalne tematyki zestawów"), size = 1) +
labs(x = "Rok", y = "Liczba tematyk", colour = "Legenda") +
scale_color_manual(values=c("#fc8d62")) +
theme_bw()
mean_nparts_data <- sets_with_themes %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(sets_mean_nparts = mean(set_num_parts, na.rm = TRUE), sets_count = n())
ggplot(mean_nparts_data , aes(x = year, y = sets_mean_nparts)) +
ggtitle("Średnia liczba części w zestawach w latach 1980-2023") +
geom_bar(stat="identity", fill = "#fc8d62") +
labs(x = "Rok", y = "Liczba części") +
theme_bw()
knitr::kable(summary(sets_with_themes), caption = "Podstawowe statystyki - zestawy Lego")
| theme_name | set_num | set_name | year | set_num_parts | |
|---|---|---|---|---|---|
| Length:21880 | Length:21880 | Length:21880 | Min. :1949 | Min. : 0.0 | |
| Class :character | Class :character | Class :character | 1st Qu.:2001 | 1st Qu.: 3.0 | |
| Mode :character | Mode :character | Mode :character | Median :2012 | Median : 31.0 | |
| Mean :2008 | Mean : 161.4 | ||||
| 3rd Qu.:2018 | 3rd Qu.: 139.0 | ||||
| Max. :2024 | Max. :11695.0 |
Kolejna część badanego zbioru danych. Możemy znaleźć tutaj informacje o figurkach m.in. z czego się one składają.
colnames(figs)[colnames(figs) == "name"] <- "fig_name"
colnames(figs)[colnames(figs) == "num_parts"] <- "fig_num_parts"
colnames(inv_figs)[colnames(inv_figs) == "quantity"] <- "fig_qty"
colnames(inventories)[colnames(inventories) == "id"] <- "inventory_id"
inventory_minifigures <- inv_figs %>%
merge(figs, by = "fig_num") %>%
merge(inventories, by = "inventory_id") %>%
merge(sets, by = "set_num") %>%
select(-c(1:2, 7:9, 11:13))
Jeśli chodzi o ilość wykorzystywanych w zestawach figurek, to możemy zauważyć, że z czasem wykorzystywane są one coraz częściej.
figures_number <- inventory_minifigures %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(fig_count = n())
ggplot(figures_number , aes(x = year, y = fig_count)) +
geom_line(aes(y = fig_count, color = "Liczba figurek"), size = 1) +
labs(x = "Rok", y = "Liczba figurek", colour = "Legenda") +
scale_color_manual(values=c("#fc8d62")) +
theme_bw()
knitr::kable(summary(inventory_minifigures), caption = "Podstawowe statystyki - figurki Lego")
| fig_num | fig_qty | fig_name | fig_num_parts | year | |
|---|---|---|---|---|---|
| Length:20858 | Min. : 1.000 | Length:20858 | Min. : 0.000 | Min. :1975 | |
| Class :character | 1st Qu.: 1.000 | Class :character | 1st Qu.: 4.000 | 1st Qu.:2006 | |
| Mode :character | Median : 1.000 | Mode :character | Median : 4.000 | Median :2014 | |
| Mean : 1.062 | Mean : 4.813 | Mean :2011 | |||
| 3rd Qu.: 1.000 | 3rd Qu.: 5.000 | 3rd Qu.:2019 | |||
| Max. :100.000 | Max. :143.000 | Max. :2023 |
Ostatania część badanego zestawu danych zawiera informacje na temat części Lego. Znajdują się tutaj szczegóły poszczególnych części: elementy z których się składają, kolory, materiał z którego zostały wykonane oraz kategoria do której przynależą.
colnames(parts)[colnames(parts) == "name"] <- "part_name"
colnames(parts_cat)[colnames(parts_cat) == "name"] <- "part_cat_name"
colnames(parts_cat)[colnames(parts_cat) == "id"] <- "part_cat_id"
colnames(colors)[colnames(colors) == "name"] <- "color_name"
colnames(colors)[colnames(colors) == "id"] <- "color_id"
colnames(inv_parts)[colnames(inv_parts) == "quantity"] <- "part_qty"
element_counts <- elements %>%
group_by(part_num, color_id) %>%
summarise(el_per_part = n())
inventory_parts <- inv_parts %>%
merge(parts, by = "part_num") %>%
merge(colors, by = "color_id") %>%
merge(parts_cat, by = "part_cat_id") %>%
merge(element_counts, by = c("part_num", "color_id")) %>%
merge(inventories, by = "inventory_id") %>%
merge(sets, by = "set_num") %>%
select(-c(1:2, 4, 7:8, 12, 16:17, 19:21))
W przypadku części Lego również można dostrzeć pewne trendy. Wykorzystywane elementy są coraz bardziej zróżnicowane, poprzez tworzenie części z nowych materiałów oraz w nowych kolorach. Warte wyróżnienia jest, że złożoność części się nie zmieniła (na jedną część średnio przypada 1.5 elementu)
transparent_parts <- inventory_parts %>%
group_by(is_trans) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(trans_part_count = n())
ggplot(transparent_parts, aes(x=is_trans, y=trans_part_count, fill=is_trans)) +
geom_bar(stat="identity", position="dodge") +
scale_fill_manual(values = c("t" = "#66c2a5", "f" = "#fc8d62"), labels = c("TAK", "NIE")) +
scale_x_discrete(labels = c("t" = "TAK", "f" = "NIE")) +
labs(title = "Zestawienie kolorów (transparentność)", x = "Transparentność", y = "Liczba obserwacji", fill = "Legenda") +
theme_bw()
unique_data <- inventory_parts %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
group_by(year, part_material) %>%
summarise(count = n(), type = "Material") %>%
bind_rows(
inventory_parts %>%
group_by(year, color_name) %>%
summarise(count = n(), type = "Color") %>%
bind_rows(
inventory_parts %>%
group_by(year, part_cat_name) %>%
summarise(count = n(), type = "Category")
)
)
ggplot(unique_data, aes(x = year, y = count, fill = type)) +
geom_bar(stat = "identity", position = "dodge") +
facet_grid(type ~ ., scales = "free_y", labeller = labeller(type = c("Material" = "Materiały", "Color" = "Kolory", "Category" = "Kategorie"))) +
scale_fill_manual(values = c("Category" = "#66c2a5", "Color" = "#fc8d62", "Material" = "#8da0cb"), labels = c("Kategorie", "Kolory", "Materiały")) +
labs(x = "Rok", y = "Liczba obserwacji", fill = "Legenda") +
theme_bw()
elements_count <- inventory_parts %>%
group_by(year) %>%
filter(year >= 1980) %>%
filter(year <= 2023) %>%
summarise(el_in_part = mean(el_per_part, na.rm = TRUE))
ggplot(elements_count , aes(x = year, y = el_in_part)) +
geom_line(aes(color = "Średnia ilość elementów w częściach"), size = 1) +
labs(x = "Rok", y = "Liczba elementów", colour = "Legenda") +
scale_color_manual(values=c("#fc8d62")) +
theme_bw()
knitr::kable(summary(inventory_parts), caption = "Podstawowe statystyki - części Lego")
| part_num | part_cat_id | part_qty | part_name | part_material | color_name | is_trans | part_cat_name | el_per_part | year | |
|---|---|---|---|---|---|---|---|---|---|---|
| Length:1040218 | Min. : 1.00 | Min. : 1.000 | Length:1040218 | Length:1040218 | Length:1040218 | Length:1040218 | Length:1040218 | Min. :1.000 | Min. :1954 | |
| Class :character | 1st Qu.:11.00 | 1st Qu.: 1.000 | Class :character | Class :character | Class :character | Class :character | Class :character | 1st Qu.:1.000 | 1st Qu.:2008 | |
| Mode :character | Median :15.00 | Median : 2.000 | Mode :character | Mode :character | Mode :character | Mode :character | Mode :character | Median :1.000 | Median :2016 | |
| Mean :21.73 | Mean : 3.566 | Mean :1.591 | Mean :2013 | |||||||
| 3rd Qu.:28.00 | 3rd Qu.: 4.000 | 3rd Qu.:2.000 | 3rd Qu.:2020 | |||||||
| Max. :68.00 | Max. :3064.000 | Max. :9.000 | Max. :2023 |
dataset <- unique_theme_data %>%
merge(mean_nparts_data) %>%
merge(figures_number) %>%
merge(transparent_parts) %>%
merge(elements_count)
knitr::kable(summary(dataset))
| year | unique_theme | sets_mean_nparts | sets_count | fig_count | is_trans | trans_part_count | el_in_part | |
|---|---|---|---|---|---|---|---|---|
| Min. :1980 | Min. :14.00 | Min. : 66.47 | Min. : 74.0 | Min. : 48.0 | Length:88 | Min. : 61982 | Min. :1.426 | |
| 1st Qu.:1991 | 1st Qu.:24.00 | 1st Qu.:102.28 | 1st Qu.: 157.5 | 1st Qu.: 135.2 | Class :character | 1st Qu.: 61982 | 1st Qu.:1.588 | |
| Median :2002 | Median :56.00 | Median :131.77 | Median : 420.0 | Median : 289.0 | Mode :character | Median :513352 | Median :1.610 | |
| Mean :2002 | Mean :53.66 | Mean :140.95 | Mean : 468.8 | Mean : 468.2 | Mean :513352 | Mean :1.598 | ||
| 3rd Qu.:2012 | 3rd Qu.:79.75 | 3rd Qu.:171.05 | 3rd Qu.: 729.5 | 3rd Qu.: 855.5 | 3rd Qu.:964721 | 3rd Qu.:1.638 | ||
| Max. :2023 | Max. :96.00 | Max. :307.83 | Max. :1149.0 | Max. :1301.0 | Max. :964721 | Max. :1.662 |
W tej sekcji przedstawiono jak na przestrzeni lat (1980-2023) zmieniały się trendy w Lego. Uwzględniono zmiany w złożoności zestawów (średniej liczby wykorzystywanych w nich części) poprzez wielkość punktu, w porównaniu z ilością wykorzystywanych w zestawach figurek oraz liczby dostępnych zestawów.
Na podstawie wykresu możemy zauważyć, że największy przeskok jeśli chodzi o zaawansowanie zestawów (ich ilośc i złożoność), przypada na okres około 2010 roku.
animation <- dataset %>%
select(year, sets_count, fig_count, sets_mean_nparts)
p <- ggplot(animation, aes(x=sets_count, y=fig_count, size = sets_mean_nparts)) +
geom_point(show.legend = FALSE, alpha = 0.8, color = "#fc8d62") +
labs(title = 'Rok: {frame_time}', x = "Liczba dostępnych zestawów", y = "Ilość wykorzystywanych figurek") +
transition_time(year) +
theme_bw()
animate(p, nframes = 225)
Na poniższym wykresie przedstawiona została wartość współczynnika korelacji Pearsona między parametrami atrybutów w zbiorze.
W tabeli przedstawiono wartości współczynnika korelacji dla poszczególnych par atrybutów.
| Wiersz | Kolumna | Współczynnik korelacji |
|---|---|---|
| fig_count | sets_count | 0.9675649 |
| unique_theme | year | 0.9640386 |
| sets_count | year | 0.9477051 |
| sets_count | unique_theme | 0.9447247 |
| fig_count | year | 0.9274481 |
| fig_count | unique_theme | 0.9067765 |
| sets_mean_nparts | year | 0.7868182 |
| fig_count | sets_mean_nparts | 0.7656128 |
| sets_count | sets_mean_nparts | 0.7039379 |
| sets_mean_nparts | unique_theme | 0.6696571 |
| el_in_part | unique_theme | 0.3051613 |
| el_in_part | year | 0.2539668 |
| el_in_part | sets_mean_nparts | -0.1348402 |
| el_in_part | sets_count | 0.1026486 |
| el_in_part | fig_count | 0.0265213 |
| sets_mean_nparts | trans_part_count | 0.0000000 |
| sets_count | trans_part_count | 0.0000000 |
| fig_count | trans_part_count | 0.0000000 |
| trans_part_count | year | 0.0000000 |
| trans_part_count | unique_theme | 0.0000000 |
| el_in_part | trans_part_count | 0.0000000 |
Wnioski wyciągnięte na podstawień obliczeń współczynnika korelacji:
W tej sekcji opisano wykorzystanie uczenia maszynowego do prognozowania złożoności zestawów Lego, czyli średniej liczby ich części. Do tego celu użyto algorytmu Random Forest, z zastosowaniem metody losowania ze zwracaniem (bootstraping).
dataset$is_trans <- as.factor(dataset$is_trans)
inTraining <-
createDataPartition(
y = dataset$sets_mean_nparts,
p = .7,
list = FALSE)
training <- dataset[inTraining,]
testing <- dataset[-inTraining,]
Przygotowano schemat uczenia wraz z optymalizacją parametrów modelu. Najlepszy model został stworzony dla parametru liczby zmiennych losowo wybranych jako kandydaci w każdym podziale (mtry) równego 4. Poza tym wybrany model charakteryzuje się najniższym błędem średniokwadratowym (RMSE), który wynosi 20.29928 Dodatkowo miara dopasowania modelu do danych (Rsquared) również jest jedną z wyższych.
rfGrid <- expand.grid(mtry = 2:20)
gridCtrl <- trainControl(method = "boot", number = 100)
fitTune <- train(sets_mean_nparts ~ .,
data = training,
method = "rf",
trControl = gridCtrl,
tuneGrid = rfGrid,
ntree = 40)
fitTune
## Random Forest
##
## 64 samples
## 7 predictor
##
## No pre-processing
## Resampling: Bootstrapped (100 reps)
## Summary of sample sizes: 64, 64, 64, 64, 64, 64, ...
## Resampling results across tuning parameters:
##
## mtry RMSE Rsquared MAE
## 2 22.51743 0.8381052 17.18059
## 3 20.72412 0.8599121 15.27948
## 4 20.32661 0.8635669 14.98439
## 5 20.47273 0.8623097 15.05096
## 6 20.59016 0.8595858 15.22843
## 7 20.62173 0.8579696 15.32871
## 8 20.54871 0.8582724 15.27627
## 9 20.88306 0.8538215 15.49705
## 10 20.86593 0.8547343 15.52240
## 11 20.38345 0.8602656 15.09059
## 12 20.52288 0.8589985 15.25982
## 13 20.51089 0.8586256 15.16584
## 14 20.47589 0.8600704 15.24469
## 15 20.50593 0.8596488 15.29586
## 16 20.73137 0.8572988 15.34260
## 17 20.52877 0.8592537 15.26166
## 18 20.61759 0.8583844 15.36097
## 19 20.69999 0.8562868 15.31274
## 20 20.48254 0.8588786 15.21346
##
## RMSE was used to select the optimal model using the smallest value.
## The final value used for the model was mtry = 4.
predictions <- predict(fitTune, newdata = testing)
important_df <- data.frame(importance(fitTune$finalModel))
important_df$names <- rownames(important_df)
ggplot(important_df, aes(x=names, y=IncNodePurity/100)) +
geom_bar(stat="identity", fill = "#fc8d62") +
labs(title = "Wykres ważności atrybutów w podejmowaniu decyzji", x="Atrybuty", y="Ważność") +
theme_bw() +
theme(axis.text.x = element_text(angle = 45, hjust=1))
Na podstawie powyższego wykresu okazuje się, że najważniejszymi atrybutami są:
compare_df <- testing %>% select(year, sets_mean_nparts)
compare_df$Predict <- predictions
ggplot(compare_df, aes(x = year)) +
geom_line(aes(y = sets_mean_nparts, color = "Rzeczywista liczba części"), size = 1) +
geom_line(aes(y = Predict, color = "Przewidywana liczba części"), size = 1) +
labs(x = "Rok", y = "Średnia liczba części w zestawie") +
scale_color_manual(name = "Legenda", values = c("Rzeczywista liczba części" = "#fc8d62", "Przewidywana liczba części" = "#8da0cb")) +
theme_bw()